c	MACX.FOR v3.2
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
c		28 Dec 84
c
c	modification history:
c
c		March 21, 1985 - Vern Keenan
c			added READONLY to all the STATUS=OLD OPENs so
c			files from another user's directory can be read.
c
c	For UPLOADING and DOWNLOADING complete Mac files from the VAX.
c		Prototype version, but format of VAX/VMS files is now
c		stable and I don't expect to change it.
c
c		Text conversion to/from VMS is NOT yet included.
c		Macintosh files are NOT in a format that can be directly
c		used by VMS.  Record length is 128 bytes.  The first
c		record contains file header information.  You can use the
c		routine READXMMAC to read it.  Data and resource forks
c		follow in that order; length is actual length rounded up
c		to multiple of 128.
c
c	Dan Smith
C	Eye Research Institute of Retina Foundation
c	20 Staniford Street
c	Boston, MA 02114
c
c		(617) 742-3140
c		CIS 74706,661
c
c	Based on J. James Belonis II's XMODEM program
c
c	Completely reworked for use with MacTerminal
c
c	Compile, link, RUN MACX, then use commands
c
c		R filename
c		S filename
c
c		works with MacTerminal with File Transfer Settings
c			XMODEM/MacTerminal
c
c		based on
c               XMODEM54.FOR  (Version 5.4)   Updated 5/14/84
c               J.James Belonis II
c               Physics Hall FM-15
c               University of Washington
c               Seattle, WA 98195
c
c  TMODEM.C written by Richard Conn, Eliot Moss, and Lauren
c   Weinstein
c
	external macxcld,errou
	external giveup
	logical cli$dcl_parse,st
	character line*80
        INTEGER*2 CHAN,STATUS(4)
        COMMON /QIO/ CHAN,STATUS
c  log file for debugging
D	open(8,file='MACX.LOG',carriagecontrol='LIST',status='NEW')
c  assign terminal channel for QIO calls to send raw bytes.
	call sys$assign('TT',chan,,)
	call userex(giveup)
	write(*,*)'MACX v3.2, copyright (c) 1985 by Eye Research Institute'
	1//' of Retina Foundation'
	write(*,*)'All rights reserved'
	iforceprompt=0
50	write(*,*)'H)elp, C)atalog, U)pload, D)ownload, Q)uit'
	write(*,*)
100	continue
	call lib$get_foreign(line,'MACX>',,iforceprompt)
c
c For the call to dcl_parse, avoid standard error handling.  Use our own
c	routine, which does nothing.  Then call "revert" to reestablish
c	standard error handling.
c
	call lib$establish(errou)
		st=cli$dcl_parse(line,macxcld)
	call lib$revert	
c
	if(st)then
		call cli$dispatch
	else
		write(*,*)'Bad command'
	end if
	go to 50
	end
	integer function errou(sigargs,mechargs)
	include '($ssdef)'
	integer sigargs(*),mechargs(5)
	errou=ss$_continue
	return
	end
	subroutine quit
	call exit
	end
	subroutine help
	external lib$put_output,lib$get_input
	call lbr$output_help(
	1	lib$put_output,
	2	80,
	3	'macx',
	4	'userc:[sci04444.macx]macx',
	5	,
	6	lib$get_input)
	return
	end
	subroutine import
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	implicit integer(a-z)
	logical status,cli$present,cli$get_value,textmode,lib$find_file
	character*80 file,outfile,filespec,temp
	call cli$get_value('file',filespec)
	status=lib$find_file(filespec,file,context,'[].txt')
	if(.not.status)then
		write(*,*)'Not found: '//filespec
		return
	endif
	i=index(file,']')
	temp=file(i+1:)
	j=index(temp,'.')-1
	outfile=file(1:i)//temp(1:j)
	if(cli$present('out'))then
		call cli$get_value('out',outfile)
	endif
	call textmac(file,outfile)
	return
	end
	function intparam(aname,idefault)
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	character aname*(*),aval*32
	logical cli$present,cli$get_value
	intparam=idefault
	if(cli$present(aname))then
		call cli$get_value(aname,aval)
		read(aval,100,err=200)ival
100		format(bn,i32)
		intparam=ival
200		continue
	end if
	return
	end
	subroutine export
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	logical status,cli$present,cli$get_value,textmode,lib$find_file
	character*80 file,outfile,filespec,temp
	character macname*63,type*4,creator*4
	call cli$get_value('file',filespec)
	status=lib$find_file(filespec,file,context,'[].mac')
	if(.not.status)then
		write(*,*)'Not found: '//filespec
		return
	endif
	call readxmmac(file,macname,n,type,creator,i,j,k,l)
	if(type.ne.'TEXT')then
		write(*,*)'Not a TEXT file, can''t export'
		return
	endif
	i=index(file,']')
	temp=file(i+1:)
	j=index(temp,'.')-1
	outfile=file(1:i)//temp(1:j)
	if(cli$present('out'))then
		call cli$get_value('out',outfile)
	endif
	call mactext(file,outfile)
	return
	end
	subroutine vmsname(macin,vmsout)
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	implicit integer(a-z)
	character mac*63,vms*9,macin*(*),vmsout*(*),c
	mac=macin
	v=0
	vms=' '
	do 100 i=1,63
	c=mac(i:i)
	if(
	1	(c.ge.'A'.and.c.le.'Z')
	2  .or. (c.ge.'a'.and.c.le.'z')
	3  .or. (c.ge.'0'.and.c.le.'9')
	4 					) then
		if(v.lt.9)then
			v=v+1
			vms(v:v)=c
		endif
	endif
100	continue
	vmsout=vms
	return
	end
	subroutine upload
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	implicit integer(a-z)
	logical status,cli$present,cli$get_value,textmode
	character*80 file,tempfile
	if(.not. cli$get_value('file',file))file=' '
	textmode=cli$present('TEXT')
	write(*,*)'Please send your file.'
	write(*,*)'     (pull down "File," select "Send File...")'
	write(*,*)
	if(textmode)then
		tempfile='macx.tmp;1'
		call recvfile(tempfile)
		call mactext(tempfile,file)
		call deletefile(tempfile)
	else
		call recvfile(file)
	end if
	return
	end
	subroutine download
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	implicit integer(a-z)
	logical status,cli$present,cli$get_value,textmode
	character*80 infilespec,prevspec,infile,tempfile
	go to 1000
50	count=0
100	continue
	status=lib$find_file(infilespec,infile,context,'.MAC',prevspec)
	prevspec=infilespec
	if(status)then
		count=count+1
		textmode=cli$present('TEXT')
		if(textmode)then
			tempfile='macx.tmp;1'
			call textmac(infile,tempfile)
			call sendfile(tempfile)
			call deletefile(tempfile)
		else
			call sendfile(infile)
		endif
		go to 100
	end if
	if(count.eq.0)write(*,*)'No files matching:'//
	1	infile(1:length(infile))
c
1000	if(cli$get_value('file',infilespec))go to 50
c
c
	return
	end
	subroutine deletefile(file)
	character*(*) file
	open(unit=1,status='unknown',file=file,dispose='delete')
	close(unit=1)
	return
	end
	function length(a)
	character*(*) a
	length=1
	l=len(a)
	do 100 i=1,l
100	if(a(i:i).ne.' ')length=i
	return
	end
c----------------------------------------------------------------
c  send file
	subroutine sendfile(file)
 
c  declare variables
C  QIO.DCK to be included in subroutines using SYS$QIOW
 
        INTEGER*2 CHAN,STATUS(4)
        COMMON /QIO/ CHAN,STATUS
	logical macfirst
	character*(*) file
	byte sector(130), c
	byte brecord(128)
	equivalence(brecord,sector)
	integer block, blocknumber, nakwait, stat, ic
	logical ttyinlim
	logical charintime, acked
 
 
	integer errorcount
	common /err/errorcount
 
	integer high,low
	common /crcval/high,low
 
	logical crc
	integer checksum
	common /checks/checksum,crc
 
	equivalence (checksum,checksumbyte)
	equivalence (ic,c)
 
 
c  define ASCII characters
	parameter NUL=0
	parameter SOH=1
	parameter EOT=4
	parameter ACK=6
	parameter NAK=21
	parameter CAN=24
c  timeouts
	parameter respnaklim=10
	parameter naklim=10
	parameter eotlim=10
	parameter errlim=3
 
	character macname*63,type*4,creator*4
	dimension isection(2)
 
	call readxmmac(file,macname,n,type,creator,idat,ires,
	1	idum,idum)
	ndat=(idat+127)/128
	nres=(ires+127)/128
	write(*,10)macname(1:n),idat,ires,idat+ires
10	format(' Sending: ',a/5x,i8,' bytes (data)',i8,
	1 ' bytes (resource)',i8,' bytes (total)')
	call delay(0.1) ! 4.0
c
	isection(1)=2
	isection(2)=2+ndat
c
	open(6,name=file,iostat=stat,status='OLD',defaultfile='.mac',
	1	readonly)
c     1         carriagecontrol='NONE',recordtype='FIXED',recl=128)
 
	if(stat) then
		write(*,*)' Can''t open '//file
	        call exit
	endif
	   call ttyout(27,1)
	   call ttyout(97,1)
	   macfirst=.true.
c
c
c
	errorcount=0
	block=1
	blocknumber=1
	nakwait=0
	crc=.false.
 
c  await first NAK (or 'C') indicating receiver is ready
  200   	charintime=ttyinlim(c,1,naklim)         ! return NUL if timeout
c       	print *,' character=',c
		if( .NOT.charintime ) then
		        nakwait=nakwait+1
c  give the turkey 10 seconds to figure out how to receive a file
		        if(nakwait.EQ.10) call cancel
		        goto 200
		elseif(c.EQ.NAK) then
		        crc=.false.
		elseif(c.EQ.CAN) then
		        call cancel
		elseif(c.eq.ACK .and. macfirst) then
			crc=.false.
			call delay(1.0)
		else
c  unrecognized character
		        nakwait=nakwait+1
		        if(nakwait.eq.10) call cancel
		        goto 200
		endif
		macfirst=.false.
  300   continue
c  send new sector
	do 350 i=1,2
	if(block.eq.isection(i))then
c
c Mark end of section
c	Note--send EOT but DON'T wait for ACK
c
D	WRITE(8,*)' About to mark end of section',i,isection(i)
  310		call delay(1.0) ! 3.0
		call ttyout(EOT,1)
		call getack(acked)
		if(.not.acked)goto310
		charintime=ttyinlim(c,1,naklim)
		if(.not.charintime)call cancel
		if(c.ne.nak)call cancel
		blocknumber=1
		call delay(1.0) ! 3.0
	end if
  350	continue
D	WRITE(8,*)' About to read block',block
	read(6,1000,end=500) (sector(i),i=1,128)
c
 1000   format(128a)
	errorcount=0
c       print *,' sector as read',sector
  400   continue
c  send sector
c       print *,' SOH '
	call ttyout(SOH,1)
	call ttyout(blocknumber,1)
	call ttyout( not(blocknumber),1 )
c       print *,' blocknumber=',blocknumber
 
	checksum=0
c  separate calls to slow down in case other end slow (can even introduce
c  delay between characters).
	do i=1,128
	        call ttyout(sector(i),1)
	enddo
c        call ttyout(sector(i),128)
c  calc checksum or crc
	        do i=1,128
	                checksum=checksum+sector(i)
	        enddo
c  this sends low order byte of checksum
	        call ttyout(checksum,1)
c               print *,' checksum',checksum
 
c  sector sent, see if receiver acknowleges
c  getack attempts to get ACK
c  if not, repeat sector
c       print*, ' should wait for ACK 10 seconds'
	call getack(acked)
c       print*, ' getack returned=',acked
	if(.NOT.acked) goto 400
 
c  ACK received, send next sector
	block=block+1
	blocknumber=blocknumber+1
	goto 300
 
c  end of file during read.  finish up sending.
  500   continue
c
c Mark end of section
c
  510		call ttyout(EOT,1)
c      getack attempts to get ACK up to errlim times
		call getack(acked)
		if( .NOT.acked ) goto 510
 
c       print *,' Sending complete.'
	close(6)
	close(8,dispose='DELETE')
	write(*,*)char(0)//char(0)//char(0)//char(0)
c	call delay(1.0)
	return
	end
 
c----------------------------------------------------------------
c  receive file
	subroutine recvfile(file)
 
c  declare variables
 
        INTEGER*2 CHAN,STATUS(4)
        COMMON /QIO/ CHAN,STATUS
	character*(*) file
	character macname*63,vmsfile*80
	byte sector(130), c, notc, checksumbyte, ck
	byte brecord(128)
	equivalence(brecord,sector)
	integer blocknumber, inotc, notnotc, secbytes, stat
	integer testblock, testprev, ic
	logical ttyinlim
	logical charintime, firstsoh
 
	integer errorcount
	common /err/errorcount
 
	integer high,low
	common /crcval/high,low
 
	logical opened
	integer checksum
	common /checks/checksum,crc
 
	equivalence (checksum,checksumbyte)
	equivalence (ic,c)
 
c  define ASCII characters
	parameter NUL=0
	parameter SOH=1
	parameter EOT=4
	parameter ACK=6
	parameter NAK=21
	parameter CAN=24
	parameter SUB=26
c  timeouts
	parameter respnaklim=10
	parameter naklim=10
	parameter eotlim=10
	parameter errlim=10
 
 
	call passall(CHAN,.TRUE.)
	opened=.false.
	secbytes=129
c
		i=0
70		last=i
		call ttyin(i,1)
		if(.not.(last.eq.27 .and. i.eq.97))go to 70
		do 1000 macfirst=1,3
c
		if(macfirst.eq.1)then
			call ttyout(ack,1)
		else
			call ttyout(nak,1)
		endif
 
 
	firstsoh=.false.
	errorcount=0
	blocknumber=1
	j=0
 
 
  800   continue
D	WRITE(8,*) ' ready for SOH'
c  must allow enough time for other's disk read (xmodem50.asm allows 10 sec)
	charintime=ttyinlim(c,1,respnaklim)
c  if no char for a while, try NAK or C again
	if( .NOT.charintime ) then
c               print*,' no response to NAK or C, trying again'
D	WRITE(8,*) ' no response to NAK or C, trying again'
	        goto 999
	endif
c  else received a char so see what it is
	if(c.eq.NUL) goto 800   ! ignore nulls here for compatablity with old
	                        ! versions of modem7
	if(c.EQ.CAN) then
	        print *,' Canceled.  Aborting.'
D	WRITE(8,*) ' Canceled.  Aborting.'
	        call exit
	endif
D	WRITE(8,*) ' EOT or SOH character=',c
	if(c.NE.EOT) then
	        IF(c.NE.SOH) then
D	WRITE(8,*) ' Not SOH, was decimal ',c
	                goto 999
	        endif
	        firstsoh=.true.
 
c  character was SOH to indicate start of header
c  get block number and complement
	        call ttyin(c,1)
D	WRITE(8,*) ' block=',c
 
	        call ttyin(notc,1)
D	WRITE(8,*) ' block complement=',notc
	        inotc=notc      ! make integer for "not" function
	        notnotc=iand( not(inotc),255 )  ! mask back to byte
 
c  c is low order byte of ic via equivalence statement
	        if(ic.NE.notnotc) then
D	WRITE(8,*) ' block check bad.'
	                goto 999
	        endif
c  block number valid but not yet checked against expected
 
	        checksum=0
 
c  receive the sector and checksum bytes in one call (for speed).
c  secbytes is 129 for checksum, 130 for CRC
	        call ttyin(sector,secbytes)
 
c  don't add received checksum byte to checksum
	                do i=1,secbytes-1
	                        checksum=checksum+sector(i)
	                enddo
	                ck=sector(129)
D	WRITE(8,2100) ck
 
D	WRITE(8,2100) checksum
D	WRITE(8,2100) checksumbyte
c 2100                  format(' checksum=',z10)
	                if( checksumbyte.NE.ck ) then
D	WRITE(8,*) ' bad checksum'
	                        goto 999
	                endif
 
c  received OK so we can believe the block number, see which block it was
c  mask it to be one byte
	        testblock=iand(blocknumber,255)
	        testprev=iand( blocknumber-1 ,255)
	        if( ic.EQ.testprev) then
D	WRITE(8,*) ' prev. block again, out of synch'
c  already have this block so don't write it, but ACK anyway to resynchronize
	                goto 985
	        elseif( ic.NE.testblock ) then
D	WRITE(8,*) ' block number bad.'
	                goto 999
	        endif
c  else was expected block
 
c  write before acknowlege so not have to listen while write.
		if(.not.opened)then
			vmsfile=file
D	WRITE(8,*)'opening, vmsfile',vmsfile
			n=sector(2)
			macname=' '
			do i=1,n
				macname(i:i)=char(sector(i+2))
			end do
D	WRITE(8,*)'macname',macname
			if(vmsfile.eq.' ')then
				call vmsname(macname,vmsfile)
			write(8,*)'vmsfile',vmsfile
			endif
		open(7,name=vmsfile,recl=128,status='NEW',iostat=stat,
	1          carriagecontrol='NONE',recordtype='FIXED',
	2	defaultfile='.mac')
			if(stat) then
				write(*,*)' Can''t open '//file
			        call exit
			endif
		opened=.true.
		endif
	             write(7,2000,err=900) (sector(i),i=1,128)
 2000                format(128a)
	        goto 975
900	continue
D	WRITE(8,*) ' Can''t write sector. Aborting.'
	        print*, ' Can''t write sector. Aborting.'
	        call exit
 
  975           continue
c  recieved sector ok, wrote it ok, so acknowlege it to request next.
	        blocknumber=blocknumber+1
c  comes here if re-received the previous sector
  985           continue
	        errorcount=0
D	WRITE(8,*) ' ACKing, sector was ok.'
	        call ttyout(ACK,1)
	        goto 800
 
c  else error so eat garbage in case out of synch and try again
  999           continue
	        call eat
D	WRITE(8,*) ' receive error NAK, block=',blocknumber
	                call ttyout(NAK,1)
	        errorcount=errorcount+1
  998           if(errorcount.GE.errlim) then
	                print*,' Unable to receive block. Aborting.'
D	WRITE(8,*) ' Not receive block. Aborting.'
c  delete incompletely received file
	                close(7,dispose='DELETE')
	                call exit
	        endif
c  retry
	        goto 800
	endif
 
c  EOT received instead of SOH so file done.
c  should keep sending ACK 'til no more EOT's ?
	if (j.NE.0) then
	write(7,2000,err=900) (sector(i),i=1,j)
	endif
	call ttyout(ACK,1)
1000	continue
	close(7)
	close(8,dispose='DELETE')
	m=length(macname)
	n=length(vmsfile)
	write(*,*)'Received Macintosh file '//macname(1:m)
	write(*,*)'            as VMS file '//vmsfile(1:n)//'.MAC'
	return
	end
 
c-------------------------------------------------------------
c-----------------------------------------------------------
c-----------------------------------------------------------
      SUBROUTINE TTYIN(LINE,N)
      BYTE LINE(*)
      INTEGER N
C              READ CHARACTERS FROM TERMINAL
C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE
C              MAY HAVE PROBLEM WITH TYPE-AHEAD
c  should convert to time-out properly with loops in main ?
 
        INTEGER*2 CHAN,STATUS(4)
        COMMON /QIO/ CHAN,STATUS
c      INCLUDE '($SSDEF)'
      parameter ss$_timeout='22c'x
      INTEGER I
      INTEGER SYS$QIOW
      INTEGER*4 terminators(2)
 
c      logical crc
c      integer checksum
c      common /checks/checksum,crc
 
      EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
      DATA terminators/0,0/
C
D	WRITE(8,*) ' inside ttyin, N=',N
      I = SYS$QIOW(,           !EVENT FLAG
     -              %VAL(CHAN),         !CHANNEL
     -              %VAL(%LOC(IO$_TTYREADALL).OR.
     -                   %LOC(IO$M_NOECHO)),         !   .OR.%LOC(IO$M_TIMED)),
     -              STATUS,,,
     -              LINE,       !BUFFER
     -              %VAL(N),    !LENGTH
     -              ,           ! max time   beware other disk time
     -                          !            and Quit or Retry time
     -              terminators,,)  !no terminators
c      if(crc) then
D	WRITE(8,1000) (LINE(j),j=1,N)
D	WRITE(8,*) ' status=',STATUS
c      else
D	WRITE(8,2000) (line(j),j=1,N)
D	WRITE(8,*) ' status=',status
c      endif
 1000 format(' ttyin=',6(20z3/),10z3)
 2000 format(' ttyin=',6(20z3/),9z3)
c      if(STATUS(1).EQ.SS$_TIMEOUT) THEN
D	WRITE(8,*) ' 10 second timeout in ttyin'
c         print*,    ' 10 second timeout in ttyin'
c         call exit
c      endif
 
      IF (I) THEN
D	WRITE(8,*) ' returning from ttyin'
	 return
      endif
C
C              ERROR
D	WRITE(8,*) ' ttyin error.'
      CALL SYS$EXIT( %VAL(I) )
      END
c-----------------------------------------------------------
	subroutine eat
c  eats extra characters 'til 1 second pause   used to re-synch after error
	byte buffer(135)
	integer numchar
	logical i,ttyinlim
c
	parameter maxtime=1
c  in case mis-interpreted header, allow at least 1 block of garbage
	numchar=135
 
	i=ttyinlim(buffer,numchar,maxtime)
c       print*,' finished eating'
D	WRITE(8,*) ' finished eating'
	return
	end
c-----------------------------------------------------------
      LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
      BYTE LINE(*)
      INTEGER N,LIMIT
C              READ CHARACTERS FROM TERMINAL
C              WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
C              RECEIVED FOR LIMIT SECONDS
C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
C              MAY HAVE PROBLEM WITH TYPE-AHEAD
 
        INTEGER*2 CHAN,STATUS(4)
        COMMON /QIO/ CHAN,STATUS
c      INCLUDE '($SSDEF)'       ! defines error status returns
      parameter ss$_timeout='22c'x
      INTEGER I
      INTEGER SYS$QIOW
      INTEGER*4 terminators(2)
      EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
      DATA TERMINATORS/0,0/
C
D	WRITE(8,*) ' inside ttyinlim'
      TTYINLIM=.TRUE.          ! DEFAULT no delay over LIMIT seconds
      I = SYS$QIOW(,           !EVENT FLAG
     -              %VAL(CHAN),         !CHANNEL
     -              %VAL(%LOC(IO$_TTYREADALL).OR.
     -                   %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
     -              STATUS,,,
     -              LINE,       !BUFFER
     -              %VAL(N),   !LENGTH
     -              %VAL(LIMIT),    !time limit in seconds
     -              terminators,,)  !no terminators
c     print*,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
D	WRITE(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
      if(STATUS(1).EQ.SS$_TIMEOUT) THEN
	 TTYINLIM=.FALSE.
D	WRITE(8,*) ' timeout'
	 return
      ENDIF
 
      IF (I) THEN
D	WRITE(8,*) ' returning from ttyinlim'
	 return
      endif
C
C              ERROR
D	WRITE(8,*) ' ttyinlim error.'
      CALL SYS$EXIT( %VAL(I) )
      END
c-----------------------------------------------------------
      SUBROUTINE TTYOUT(LINE,N)
      BYTE LINE(*)
      INTEGER*2 N
C  output N characters without interpretation
 
        INTEGER*2 CHAN,STATUS(4)
        COMMON /QIO/ CHAN,STATUS
      INTEGER I
      INTEGER SYS$QIOW
      EXTERNAL IO$M_NOFORMAT
      EXTERNAL IO$_WRITEVBLK
C
      IF ( N.LE.0 ) RETURN
C
c       print *, ' to be sent by ttyout ', line(1)
      I = SYS$QIOW(,
     -              %VAL(CHAN),
     -              %VAL(%LOC(IO$_WRITEVBLK).OR.
     -                   %LOC(IO$M_NOFORMAT)),
     -              STATUS,,,
     -              LINE,
     -              %VAL(N),,
     -              %VAL(0),, )         !NO CARRIAGE CONTROL
      if(I) then
	 return
      endif
C
C              ERROR
D	WRITE(8,*) ' ttyout error.'
      CALL SYS$EXIT( %VAL(I) )
      END
c--------------------------------------------------
	subroutine giveup
c  this exit routine used especially in case exited via QIO problem
 
        INTEGER*2 CHAN,STATUS(4)
        COMMON /QIO/ CHAN,STATUS
 
c  note: if want log file message, must re-open since
c  system already closed all files before this exit handler got control
c       open(8,file='MACX.LOG',access='APPEND')
D	WRITE(8,*) ' Exit handler.'
 
c  turn off passall
	call passall(CHAN,.FALSE.)
	return
	end
c-----------------------------------------------------
	SUBROUTINE PASSALL(CHAN,SWITCH)
C  sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
	IMPLICIT INTEGER (A-Z)
c       INCLUDE '($TTDEF)'
	parameter tt$m_passall=1
	parameter tt$m_eightbit='8000'x
	parameter io$_sensemode='27'x
	parameter io$_setmode='23'x
c       INCLUDE '($IODEF)'
	LOGICAL SWITCH
	COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH   !byte reversed LENGTH
	BYTE CLASS,TYPE,CHARAC,LENGTH
	INTEGER*2 WIDTH,SPEED
	EQUIVALENCE(CHARACTER,CHARAC)
 
c  sense current terminal driver mode
	ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
	1 CLASS,,,,,)
	IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)
 
	IF(SWITCH) THEN
c  turn on 8 bit passall
	        CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
	1                               TT$M_EIGHTBIT
	ELSE
c  turn off 8 bit passall
	        CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
	1                               .NOT.TT$M_EIGHTBIT
	ENDIF
	SPEED=0 !LEAVE SPEED UNCHANGED
	PAR=0   !LEAVE PARITY UNCHANGED
 
c  set terminal mode with desired passall
	ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
	1               CLASS,,%VAL(SPEED),,%VAL(PAR),)
	IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
	RETURN
	END
c---------------------------------------------------
	SUBROUTINE ERROR(STRING,MSGID)
c               Types error message
	IMPLICIT INTEGER(A-Z)
	CHARACTER*(*) STRING
	CHARACTER*80 MESSAGE
 
	TYPE *,' *** ERROR: ',STRING
D	WRITE(8,*) ' *** ERROR: ',STRING
	CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
	TYPE *,MESSAGE(1:MSGLEN),CRLF
D	WRITE(8,*) MESSAGE(1:MSGLEN),CRLF
	RETURN
	END
c-----------------------------------------------------------
	subroutine cancel
 
        INTEGER*2 CHAN,STATUS(4)
        COMMON /QIO/ CHAN,STATUS
c  called to cancel send (at least)
	logical charintime,ttyinlim
	byte c
	parameter CAN=24
	parameter SPACE=32
 
c  eat garbage
  100   charintime=ttyinlim(c,1,1)
	if(.NOT.charintime) goto 100
c  cancel other end
	call ttyout(CAN,1)
 
c  eat garbage in case it didn't understand ?
  200   charintime=ttyinlim(c,1,1)
	if(.NOT.charintime) goto 200
c  clear the CAN from far end's input  ???? why ? xmodem50.asm does it
	call ttyout(SPACE,1)
 
c       print*,' XMODEM program canceled'
D	WRITE(8,*)' XMODEM program canceled'
	call exit
	end
c------------------------------------------------------
	subroutine getack(acked)
c  returns .TRUE. if gets ACK
	logical charintime, ttyinlim, acked
	byte sector(130),c
 
	integer errorcount
	common /err/errorcount
 
	parameter ACK=6
	parameter errlim=10     ! max number of errors
	parameter eotlim=10     ! seconds to wait for eot
 
c       print*,' inside getack'
c  empty typeahead in case garbage
c       charintime=ttyinlim(sector,130,0)
c  allow time for file close at other end.
	charintime=ttyinlim(c,1,eotlim)
c       print*,' getack got',c
	if( .NOT.charintime .OR. c.NE.ACK ) then
c               print*, ' not ACK, decimal=',c
D	WRITE(8,*) ' not ACK, decimal=',c
	        errorcount=errorcount+1
	        if(errorcount.GE.errlim) then
D	WRITE(8,*) ' not acknowleged in 10 tries.'
	                print*,' Can''t send sector. Aborting.'
	                call exit
	        endif
	        acked=.FALSE.
	else
c  received ACK
	        acked=.TRUE.
	endif
	return
	end
	subroutine delay(d)
	t=secnds(0.0)
10	if(secnds(t).lt.d)go to 10
	return
	end
	subroutine readxmmac(file,macname,nchars,type,creator,
	1	ldata,lres,icreated,modified)
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	character file*(*),macname*(*),type*4,creator*4
	byte version,ncharsbyte
	character name*63,filler*10
	open(unit=1,file=file,status='old',readonly
	1		,form='unformatted')
	read(1)version,ncharsbyte,name,type,creator,filler,
	1		ldata,lres,icreated,modified
	close(unit=1)
	nchars=ncharsbyte
c
	call flip4(ldata)
	call flip4(lres)
	call flip4(icreated)
	call flip4(modified)
c
	macname=name(1:nchars)
	return
	end
	subroutine flip4(i)
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	integer*4 i,j
	byte k(4),temp
	equivalence(j,k)
	j=i
c
	temp=k(1)
	k(1)=k(4)
	k(4)=temp
c
	temp=k(2)
	k(2)=k(3)
	k(3)=temp
c
	i=j
	return
	end
	subroutine mactext(infile,outfile)
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	implicit integer(a-z)
	character*(*)infile,outfile
	character buf*128,line*300
	character name*63,filler*10,type*4,creator*4
	character c
	character*20 x1,x2
	byte version,ncharsbyte
	call readxmmac(infile,name,nchars,type,creator,
	1		ldata,lres,icreated,modified)
	if(type.ne.'TEXT')then
		write(*,*)infile//'--bad, type = '//type//
	1		' (should be TEXT)'
		write(*,*)'No file written'
		return
	end if
	iwrap=intparam('WRAP',79)
	open(unit=1,file=infile,status='old',form='unformatted',readonly,
	1	defaultfile='.mac')
	open(unit=2,file=outfile,status='new',carriagecontrol='list',
	1	form='formatted',defaultfile='.txt')
	read(1)buf
	b=128
	l=0
	break=0
	do 1000 i=1,ldata
	if(b.ge.128)then
		read(1)buf
		b=0
	endif
	b=b+1
	c=buf(b:b)
	if(c.eq.char(13) .or. i.eq.ldata)then
		if(l.gt.0)then
			write(2,100)line(1:l)
100			format(a)
		else
			write(2,100)
		endif
		l=0
		break=0
	else
		l=l+1
		line(l:l)=c
		if(c.eq.' ')break=l
		if(l.ge.iwrap.and.break.ne.0)then
			write(2,100)line(1:break-1)
			line=line(break+1:)
			l=l-break
			break=0
		endif
	endif
1000	continue
	close(1)
	close(2)
	return
	end
	subroutine textmac(infile,outfile)
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	implicit integer(a-z)
	character*(*)infile,outfile
	character header*128,buf*128,line*300,fullname*80
	byte version,ncharsbyte
	character name*63,filler*10,type*4,creator*4
c
	open (unit=1,file=infile,status='old',defaultfile='.txt',
	1	readonly)
	inquire(unit=1,name=fullname)
	open (unit=2,file=outfile,status='new',recl=128,access='direct',
	1	recordtype='fixed',defaultfile='.mac')
	block=1
	nchars=0
	nbuf=0
	buf=' '
	last=0
100	continue
	read(1,110,end=200)n,line
110	format(q,a)
	n=n+1
	line(n:n)=char(13)
	do 120 i=1,n
	nbuf=nbuf+1
	nchars=nchars+1
	buf(nbuf:nbuf)=line(i:i)
	if(nbuf.ge.128)then
		block=block+1
		write(2'block)buf(1:128)
		nbuf=0
		buf=' '
	end if
120	continue
	go to 100
200	continue
	block=block+1
	write(2'block)buf(1:128)
c
	version=0
	i1=index(fullname,']')+1
	i2=index(fullname,';')-1
	ncharsbyte=i2-i1+1
	name=fullname(i1:i2)
	type='TEXT'
	creator='MACA'
	filler=' '
	ldata=nchars
	lres=0
	call todaymac(icreated)
	modified=icreated
c
	call flip4(ldata)
	call flip4(lres)
	call flip4(icreated)
	call flip4(modified)
	write(2'1)version,ncharsbyte,name,type,creator,filler,
	1		ldata,lres,icreated,modified
	close(1)
	close(2)
	return
	end
	subroutine todaymac(mac)
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	character*32 today,macdate
	integer vax(2),offset(2),macstart(2)
	call lib$emul(65536*16384,40000000,0,offset)
	call sys$bintim('1-JAN-1904 00:00:00.00',macstart)
	call lib$date_time(today)
	call sys$bintim(today,vax)
	call lib$subx(vax,macstart,vax)
	call lib$subx(vax,offset,vax)
	call lib$ediv(10000000,vax,mac,irem)
	return
	end
	subroutine timemacvax(mac,vax)
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	integer vax(2),offset(2)
c
c	Mac is seconds since Jan 1, 1904
c	Vax is 100-nanosecond units since Nov 17, 1858
c
c	Convert units
c
	call lib$emul(mac,10000000,0,vax)
c
c	"Mac" should be interpreted as a 32-bit UNSIGNED integer.  For
c	dates since the Mac was built, the sign bit is set.  Offset calc.
c	is a kludge (idea is to get 65536*65536*10000000)
c
	if(mac.lt.0)then
		call lib$emul(65536*16384,40000000,0,offset)
		call lib$addx(offset,vax,vax)
	endif
c
c	Get VAX representation of Mac starting time
c
	call sys$bintim('1-JAN-1904 00:00:00.00',macstart)
c
c	Add starting time
c
	call lib$addx(macstart,vax,vax)
	return
	end
	character*(*) function macdate(mac)
	dimension vax(2)
	call timemacvax(mac,vax)
	call lib$sys_asctim(,macdate,vax)
	return
	end
	subroutine catalog
c	*********************************************************
c	*							*
c	*	This subprogram copyright (c) 1985 by		*
c	*	Eye Research Institute of Retina Foundation	*
c	*		ALL RIGHTS RESERVED			*
c	*							*
c	*********************************************************
	implicit integer(a-z)
	logical status,cli$present,cli$get_value
	character*80 infilespec,infile,temp
	character*16 file
	character*23 macdate,datecr,datemod
c
	character typecr*16,type*4,creator*4,name*63
c
	go to 1000
10	continue
	nfound=0
100	continue
	status=lib$find_file(infilespec,infile,context,'*.mac')
	if(status)then
c
c 	Print header.  This way of doing it is supposed to make it
c		easier for me to modify the formats.
		nfound=nfound+1
		if(nfound.eq.1)then
			file='VMS name'
			name='Macintosh file'
			typecr='Type'
			datemod='Last modified'
			write(*,105)file(1:10),name(1:20),typecr,
	1			datemod
		endif
c
		call readxmmac(infile,name,nchars,type,creator,
	1		ldata,lres,icreated,modified)
c
		i1=index(infile,']')+1
		temp=infile(i1:)
		i2=index(temp,'.')-1
		file=temp(1:i2)
c
		datecr=macdate(icreated)
		datemod=macdate(modified)
		K=(ldata+1023)/1024 + (lres+1023)/1024
c
		if(creator.eq.'MACA')then
			typecr='MacWrite '//type
		else if(type .eq. 'APPL')then
			typecr='Application'
		else if(creator//type .eq. 'FMOVFFIL')then
			typecr='Font Mover file'
		else if(creator//type .eq. 'MPNTPNTG')then
			typecr='MacPaint'
		else if(creator//type .eq. 'MMMUMUSC')then
			typecr='MusicWorks'
		else
			typecr=creator//' '//type
		end if
c
		write(*,110)file(1:10),name(1:20),typecr,k,datemod(1:20)
105		format(//1x,a,1x,a,1x,a,' Size  ',a/)
110		format(1x,a,1x,a,1x,a,i4,3hK  ,a)
		go to 100
	endif
1000	if(cli$get_value('file',infilespec))go to 10
	return
	end
 
